home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / program / p063b9s.zip / UNIT / REPACKER.PAS < prev    next >
Pascal/Delphi Source File  |  1996-04-22  |  9KB  |  304 lines
  1. UNIT Repacker;
  2. {╔══════════════════════════════════════════════════════════════════════════╗}
  3. {║ Repacker with A.I.                            Last changed: 22.04.96  SA ║}
  4. {║                                                                          ║}
  5. {║                         (C) Copyright 1989-96 by                         ║}
  6. {║       Dan Wulff, Jens Sandalgaard, Steen Christensen & S¢ren Ager        ║}
  7. {║                                                                          ║}
  8. {║ This source may not be given to anybody, without the written permission  ║}
  9. {║ from The Portal Team.                                                    ║}
  10. {╚══════════════════════════════════════════════════════════════════════════╝}
  11. {$I POPDEFS.INC}
  12.  
  13. INTERFACE
  14.  
  15. USES Use32;
  16.  
  17. PROCEDURE RunRepacker;
  18.  
  19. IMPLEMENTATION
  20.  
  21. USES Dos, PoPTypes, ArcView, Globals, Input, FileUtil, Util,
  22.      MailUtil, StrUtil, ApTimer, MTask, Fossil, KeyBoard, OpCrt, OpDos,
  23.      OpString, OpWindow, OproUtil, OpEntry, OpCmd;
  24.  
  25. PROCEDURE RunRepacker;
  26. VAR
  27.   t:EventTimer;
  28.   Temp:WindowPtr;
  29.   RepackPath:PathStr;
  30.   Recursive, Ai, TrySelf   :BOOLEAN;
  31.   FromPacker,ToPacker:ARRAY[1..7] OF BOOLEAN;
  32.  
  33.   FUNCTION GetInfo:BOOLEAN;
  34.   VAR
  35.     Esr:TPoPEntryScreen;
  36.     ExitCommand:WORD;
  37.     i:BYTE;
  38.   BEGIN
  39.     GetInfo:=False;
  40.  
  41.     TrySelf:=True;
  42.     Ai:=True;
  43.     Recursive:=True;
  44.     FILLCHAR(FromPacker,SizeOf(FromPacker),1);
  45.     FILLCHAR(ToPacker,SizeOf(ToPacker),1);
  46.     ESR.Init(2,3,79,ScreenHeight-4,2,'Run parameters');
  47.     WITH Esr DO
  48.     BEGIN
  49.       AddYesNoField('Only convert if saved space : ',2,2,'',2,32,0,Ai);
  50.       AddYesNoField('Try packing with same arc   : ',4,2,'',4,32,0,TrySelf);
  51.       AddYesNoField('Convert arcs inside arcs    : ',6,2,'',6,32,0,Recursive);
  52.       AddTextField('      From     To',8,1);
  53.       FOR i:=1 TO 7 DO
  54.       BEGIN
  55.         AddYesNoField(PackerExtension(i)+' :',8+i,2,'',8+i,10,0,FromPacker[i]);
  56.         AddYesNoField('',8+i,2,'',8+i,17,0,ToPacker[i]);
  57.       END;
  58.       Process;
  59.     END;
  60.     ExitCommand:=ESR.GetLastCommand;
  61.     Esr.Done;
  62.     IF ExitCommand<>ccQuit THEN
  63.     BEGIN
  64.       RepackPath:=StartPath;
  65.       IF NOT SelectPath(RepackPath) THEN Exit;
  66.     END ELSE
  67.       Exit;
  68.  
  69.     GetInfo:=True;
  70.   END;
  71.  
  72.   FUNCTION DeleteWorkDir(CONST WorkDir,NewPath:PathStr):BOOLEAN;
  73.   VAR
  74.     Error:BOOLEAN;
  75.  
  76.     PROCEDURE KillFiles(CONST Dir:PathStr);
  77.     VAR
  78.       sr:SEARCHREC;
  79.     BEGIN
  80.       FINDFIRST(Dir+'\*.*',AnyFile,sr);
  81.       WHILE DOSERROR=0 DO
  82.       BEGIN
  83.         IF sr.attr AND Directory=0 THEN
  84.         BEGIN
  85.           IF NOT DeleteFile(Dir+'\'+sr.name) THEN
  86.           BEGIN
  87.             FindClose(sr);
  88.             Error:=True;
  89.             EXIT;
  90.           END;
  91.         END;
  92.         FINDNEXT(sr);
  93.       END;
  94.       FindClose(sr);
  95.     END;
  96.  
  97.     PROCEDURE KillDirs(CONST Dir:PathStr);
  98.     VAR
  99.       sr:SEARCHREC;
  100.     BEGIN
  101.       FINDFIRST(Dir+'\*.*',Directory,sr);
  102.       WHILE DOSERROR=0 DO
  103.       BEGIN
  104.         IF (sr.attr AND Directory<>0) AND (sr.name[1]<>'.') THEN
  105.         BEGIN
  106.           RmDir(Dir+'\'+sr.name);
  107.           IF IORESULT<>0 THEN
  108.           BEGIN
  109.             FindClose(sr);
  110.             Error:=True;
  111.             EXIT;
  112.           END;
  113.         END;
  114.         FINDNEXT(sr);
  115.       END;
  116.       FindClose(sr);
  117.     END;
  118.  
  119.     PROCEDURE ParseDir(CONST Dir:PathStr);
  120.     VAR
  121.       DTA : SearchRec;
  122.     BEGIN
  123.       IF NOT Error THEN KillFiles(Dir);
  124.       FINDFIRST(Dir+'\*.*',Directory,DTA);
  125.       WHILE (DosError=0) AND NOT Error DO
  126.       BEGIN
  127.         IF ((DTA.Attr AND Directory<>0) AND (DTA.Name[1]<>'.')) THEN ParseDir(Dir+'\'+DTA.Name);
  128.         IF NOT Error THEN KillDirs(Dir);
  129.         FINDNEXT(DTA);
  130.       END;
  131.       FindClose(DTA);
  132.     END;
  133.  
  134.   BEGIN
  135.     Error:=False;
  136.     IF NOT ChangeDir(NewPath) THEN WriteLn('Error changing to: '+NewPath);
  137.     IF IsDirectory(WorkDir) THEN
  138.     BEGIN
  139.       IF WorkDir<>'' THEN ParseDir(WorkDir);
  140.       RmDir(WorkDir);
  141.     END;
  142.     DeleteWorkDir:=NOT Error;
  143.   END;
  144.  
  145.   PROCEDURE TryRepacking(CONST FileName:PathStr; Nesting:BYTE);
  146.   VAR
  147.     sr:SEARCHREC;
  148.     i,x,y:SHORTINT;
  149.     CurrentName,GemDir,WorkDir,ArcName:PathStr;
  150.     BestSize,OldSize,NewSize:LONGINT;
  151.     DidSomething, Flag:BOOLEAN;
  152.  
  153.     PROCEDURE UpdateBest;
  154.     BEGIN
  155.       BestSize:=NewSize;
  156.       WriteLn('Conversion to ',PackerExtension(i),' saved ',OldSize-BestSize,' byte(s)');
  157.       DeleteFile(CurrentName);
  158.       CurrentName:=ForceExtension(FileName,PackerExtension(i));
  159.       RenameFile(ArcName,CurrentName);
  160.     END;
  161.  
  162.     PROCEDURE UpdateFilesBBS;
  163.     VAR
  164.       ind,ud:TEXT;
  165.       oldname,newname:S13;
  166.       p:PathStr;
  167.       s:STRING;
  168.     BEGIN
  169.       p:=JustPathName(FileName);
  170.       oldname:=JustFileName(FileName);
  171.       newname:=CPad(JustFileName(CurrentName),13);
  172.       ASSIGN(Ind,p+'\FILES.BBS'); RESET(ind);
  173.       IF IORESULT=0 THEN
  174.       BEGIN
  175.         WriteLn('Updating FILES.BBS');
  176.         ASSIGN(ud,p+'\FILES.$$$'); REWRITE(ud);
  177.         WHILE NOT EOF(ind) DO
  178.         BEGIN
  179.           READLN(Ind,s);
  180.           IF COPY(s,1,LENGTH(OldName))=oldname THEN
  181.           BEGIN
  182.             DELETE(s,1,13);
  183.             INSERT(newname,s,1);
  184.           END;
  185.           WriteLn(ud,s);
  186.         END;
  187.         Close(ud);
  188.         Close(ind);
  189.         DeleteFile(p+'\FILES.BAK');
  190.         RenameFile(p+'\FILES.BBS',p+'\FILES.BAK');
  191.         RenameFile(p+'\FILES.$$$',p+'\FILES.BBS');
  192.       END;
  193.     END;
  194.  
  195.     FUNCTION Indent:STRING;
  196.     BEGIN
  197.       Indent:=CharStr(' ',2*Nesting);
  198.     END;
  199.  
  200.   BEGIN
  201.     GetDir(0,GemDir);
  202.     DidSomething:=False;
  203.     REPEAT
  204.       WorkDir:=StartPath[1]+':\POPREPAK.$'+HexB(Cfg.TaskNumber)+'\'+COPY(InventPktName,1,8);
  205.       MkDir(WorkDir);
  206.     UNTIL IORESULT=0;
  207.     x:=ArcType(FileName);
  208.     IF (x>0) AND (x<>127) THEN { Known packer, and not a GIF }
  209.     BEGIN
  210.       FINDFIRST(FileName,AnyFile,sr);
  211.       FindClose(sr);
  212.       OldSize:=sr.Size;
  213.       BestSize:=OldSize;
  214.       IF NOT ChangeDir(WorkDir) THEN WriteLn('Error changing to: '+WorkDir);
  215.       IF (FromPacker[x]) THEN
  216.       BEGIN
  217.         WriteLn(Indent,'Unpacking ',JustFileName(FileName));
  218.         IF ArcCommand(x,2,FileName,'*.*') THEN
  219.         BEGIN
  220.           DidSomething:=True;
  221.           IF Recursive THEN
  222.           BEGIN
  223.             FINDFIRST(WorkDir+'\*.*',AnyFile,sr);
  224.             WHILE DOSERROR=0 DO
  225.             BEGIN
  226.               y:=ArcType(WorkDir+'\'+sr.name);
  227.               IF (y>0) AND (FromPacker[y]) THEN TryRepacking(WorkDir+'\'+sr.name,Nesting+1);
  228.               FINDNEXT(sr);
  229.             END;
  230.             FindClose(sr);
  231.           END;
  232.           ArcName:=ForceExtension(JustPathName(FileName)+'\'+InventPktName,'TMP');
  233.           CurrentName:=FileName;
  234.           FOR i:=1 TO 7 DO
  235.           BEGIN
  236.             Flag:=ToPacker[i];
  237.             IF Flag AND (x=i) AND (NOT TrySelf) THEN Flag:=False;
  238.             IF Flag THEN
  239.             BEGIN
  240.               WRITE(Indent,'Packing with ',PackerExtension(i),'  ');
  241.               IF ArcCommand(i,1,ArcName,'*.*') THEN
  242.               BEGIN
  243.                 IF ExistFile(ArcName) THEN
  244.                 BEGIN
  245.                   IF (Ai) THEN
  246.                   BEGIN
  247.                     FINDFIRST(ArcName,AnyFile,sr);
  248.                     FindClose(sr);
  249.                     NewSize:=sr.Size;
  250.                     IF NewSize>BestSize THEN
  251.                     BEGIN
  252.                       DeleteFile(ArcName);
  253.                       WriteLn('Conversion would have wasted ',NewSize-BestSize,' byte(s)');
  254.                     END ELSE
  255.                       UpdateBest;
  256.                   END ELSE
  257.                     UpdateBest;
  258.                 END ELSE
  259.                   WriteLn('Packer created no archive');
  260.               END ELSE
  261.                 WriteLn;
  262.             END;
  263.           END;
  264.           IF (Nesting=0) AND (CurrentName<>FileName) THEN UpdateFilesBBS;
  265.           DeleteWorkDir(WorkDir,GemDir);
  266.         END ELSE
  267.         BEGIN
  268.           DeleteWorkDir(WorkDir,GemDir);
  269.           WriteLn;
  270.         END;
  271.       END;
  272.     END ELSE
  273.       DeleteWorkDir(WorkDir,GemDir);
  274.     IF DidSomething AND (Nesting=0) THEN WriteLn('Cleaning up');
  275.   END;
  276.  
  277.   PROCEDURE DoRepacker;
  278.   VAR
  279.     sr:SEARCHREC;
  280.   BEGIN
  281.     FINDFIRST(RepackPath+'\*.*',Archive,sr);
  282.     WHILE DOSERROR=0 DO
  283.     BEGIN
  284.       TryRepacking(RepackPath+'\'+sr.name,0);
  285.       FINDNEXT(sr);
  286.     END;
  287.     FindClose(sr);
  288.   END;
  289.  
  290. BEGIN
  291.   MyWin(Temp,1,2,80,ScreenHeight,2,'Repacker',False);
  292.   MkDir(StartPath[1]+':\POPREPAK.$'+HexB(Cfg.TaskNumber));
  293.   IF IOResult=0 THEN ;
  294.   IF GetInfo THEN DoRepacker;
  295.   NewTimerSecs(t,5);
  296.   WHILE (NOT TimerExpired(t)) AND (NOT FKeyPressed) AND (NOT PoPKeyPressed) DO
  297.     GiveUpTime;
  298.   IF KeyPressed THEN PoPReadKeyWord;
  299.   DeleteWorkDir(StartPath[1]+':\POPREPAK.$'+HexB(Cfg.TaskNumber),COPY(StartPath,1,LENGTH(StartPath)-1));
  300.   KillWindow(Temp);
  301. END;
  302.  
  303. END.
  304.